MacHack 1998

home *** CD-ROM | disk | FTP | other *** search

/ MacHack 1998 / MacHack 1998.toast / The Hacks! / OFPong1.0d1 / OFPong.of < prev

Wrap

Text File | 1998-06-21 | 10.2 KB | 502 lines | [TEXT/R*ch]

dl decimal 0 value gscreen " screen" open-dev to gscreen 0 value gkbd " kbd" open-dev to gkbd 0 value erasecol -1 value drawcol 0 value key_left_up 0 value key_left_down 0 value key_right_up 0 value key_right_down 0 value key_esc 0 value key_off get-msecs value grandseed 0 value glastupdate 0 value loopcount 0 value totalupdate 0 value ballstop 0 value ballx 0 value bally 0 value balldx 0 value balldy 0 value leftbaty 0 value rightbaty 0 value batdy 0 value leftscore 0 value rightscore 640 value screenx 480 value screeny : screen-prop@ ( prop-name prop-len -- value ) gscreen ihandle>phandle get-package-property 0= if decode-int -rot 2drop else 256 then ; " width" screen-prop@ to screenx " height" screen-prop@ to screeny 20 value ballsize ballsize 2 / value scoresize ballsize 5 * value batsize 1000 value pscale screenx ballsize - pscale * value ball_limit_x ballsize pscale * value ball_limit_lo_y screeny ballsize 2 * - pscale * value ball_limit_hi_y ballsize pscale * value bat_limit_lo_y screeny ballsize batsize + - pscale * value bat_limit_hi_y 0 value hit_limit_left_lo_x ballsize 2 * pscale * value hit_limit_left_hi_x screenx ballsize 3 * - pscale * value hit_limit_right_lo_x screenx ballsize - pscale * value hit_limit_right_hi_x ballsize pscale * value reflect_left_x screenx ballsize 2 * - pscale * value reflect_right_x : random ( -- n ) grandseed 16807 * 17 + abs to grandseed grandseed 1000 mod ; : unscale ( n -- n ) pscale 2 / + pscale / ; : calcbatx ( n -- x ) screenx ballsize 3 * - * ballsize + ; : paintrect ( c pixx pixy pixw pixh -- ) " fill-rectangle" gscreen $call-method ; : rectcol ( startx starty x1 y1 x2 y2 c -- startx starty ) { startx starty x1 y1 x2 y2 c } c x1 scoresize * startx + y1 scoresize * starty + x2 x1 - scoresize * y2 y1 - scoresize * paintrect startx starty ; : blackrect ( startx starty x1 y1 x2 y2 -- ) drawcol rectcol ; : whiterect ( startx starty x1 y1 x2 y2 -- ) erasecol rectcol ; : drawblank ( startx starty -- startx starty ) 0 0 4 7 whiterect ; : drawzero ( startx starty -- startx starty ) 0 0 1 7 blackrect 1 0 3 1 blackrect 1 6 3 7 blackrect 3 0 4 7 blackrect 1 3 3 4 whiterect ; : drawone ( startx starty -- startx starty ) 3 0 4 7 blackrect 0 0 3 7 whiterect ; : drawtwo ( startx starty -- ) 0 0 4 1 blackrect 3 1 4 3 blackrect 0 3 4 4 blackrect 0 4 1 6 blackrect 0 6 4 7 blackrect 0 1 1 3 whiterect 3 4 4 6 whiterect ; : drawthree ( startx starty -- startx starty ) 0 0 4 1 blackrect 3 1 4 3 blackrect 0 3 4 4 blackrect 3 4 4 6 blackrect 0 6 4 7 blackrect 0 1 1 3 whiterect 0 4 1 6 whiterect ; : drawfour ( startx starty -- startx starty ) 0 0 1 3 blackrect 0 3 3 4 blackrect 3 0 4 7 blackrect 1 0 3 1 whiterect 0 4 3 7 whiterect ; : drawfive ( startx starty -- startx starty ) 0 0 4 1 blackrect 0 1 1 3 blackrect 0 3 4 4 blackrect 3 4 4 6 blackrect 0 6 4 7 blackrect 3 1 4 3 whiterect 0 4 1 6 whiterect ; : drawsix ( startx starty -- startx starty ) 0 0 1 7 blackrect 1 3 3 4 blackrect 1 6 3 7 blackrect 3 3 4 7 blackrect 1 0 4 3 whiterect ; : drawseven ( startx starty -- startx starty ) 0 0 3 1 blackrect 3 0 4 7 blackrect 0 1 3 7 whiterect ; : draweight ( startx starty -- startx starty ) 0 0 4 1 blackrect 0 1 1 3 blackrect 3 1 4 3 blackrect 0 3 4 4 blackrect 0 4 1 6 blackrect 3 4 4 6 blackrect 0 6 4 7 blackrect ; : drawnine ( startx starty -- startx starty ) 0 0 1 4 blackrect 1 0 3 1 blackrect 1 3 3 4 blackrect 3 0 4 7 blackrect 0 4 3 7 whiterect ; : drawdigit ( startx starty n -- ) { n } n 0 = if drawzero then n 1 = if drawone then n 2 = if drawtwo then n 3 = if drawthree then n 4 = if drawfour then n 5 = if drawfive then n 6 = if drawsix then n 7 = if drawseven then n 8 = if draweight then n 9 = if drawnine then 2drop ; : drawnumber ( startx starty num -- ) { startx starty num } startx starty num abs 100 mod 10 / drawdigit startx scoresize 5 * + starty num abs 10 mod drawdigit ; : plotball ( x y -- ) { x y } drawcol x unscale y unscale ballsize ballsize paintrect ; : eraseball ( x y -- ) { x y } erasecol x unscale y unscale ballsize ballsize paintrect ; : plotbat ( n y -- ) { n y } drawcol n calcbatx y unscale ballsize batsize paintrect ; : erasebat ( n y -- ) { n y } erasecol n calcbatx y unscale ballsize batsize paintrect ; : redraw ( -- ) drawcol 0 0 screenx ballsize paintrect drawcol 0 screeny ballsize - screenx ballsize paintrect drawcol screenx scoresize - 2 / ballsize 2 * scoresize screeny ballsize 4 * - paintrect ballsize 7 * ballsize 2 * leftscore drawnumber screenx ballsize 7 * 9 scoresize * + - ballsize 2 * rightscore drawnumber 0 leftbaty plotbat 1 rightbaty plotbat ballx bally plotball ; : drawboard ( -- ) drawcol 0 0 screenx screeny paintrect erasecol 0 0 screenx screeny paintrect redraw ; : resetball ( -- ) 500 to ballstop screenx ballsize - 2 / pscale * ballx pscale mod + random + to ballx screeny ballsize - 2 / pscale * bally pscale mod + random + to bally random screenx pscale * * 2000000 / to balldx random screeny pscale * * 2000000 / to balldy balldx screenx pscale * 3000 / + to balldx balldy screeny pscale * 6000 / + to balldy random 500 < if balldx negate to balldx then random 500 < if balldy negate to balldy then ; : initvalues ( -- ) ballsize 2 * pscale * to leftbaty screeny ballsize 2 * - batsize - pscale * to rightbaty screeny pscale * 1000 / to batdy ; : doreset ( -- ) resetball 0 to leftscore 0 to rightscore drawboard ; : testkey ( map index mask -- bool ) { map index mask } map index ca+ c@ mask and 0<> ; : scankeys ( -- ) " get-key-map" gkbd $call-method drop dup 0 128 testkey to key_left_up dup 0 2 testkey to key_left_down dup 4 1 testkey to key_right_up dup 5 8 testkey to key_right_down dup 6 4 testkey to key_esc dup 6 16 testkey to key_off drop ; : moveball ( oldx oldy newx newy -- ) { oldx oldy newx newy } oldx oldy eraseball newx newy plotball ; : doupdateball ( delta -- ) ballx swap bally swap dup balldx * ballx + to ballx balldy * bally + to bally ballx 0< if resetball balldx abs negate to balldx ballx ballsize 2 * pscale * + to ballx rightscore 1 + to rightscore rightscore 15 = if -1 to ballstop then then ballx ball_limit_x > if resetball balldx abs to balldx ballx ballsize 2 * pscale * - to ballx leftscore 1 + to leftscore leftscore 15 = if -1 to ballstop then then bally ball_limit_lo_y < if balldy negate to balldy ball_limit_lo_y 2 * bally - to bally then bally ball_limit_hi_y > if balldy negate to balldy ball_limit_hi_y 2 * bally - to bally then balldx 0< if ballx hit_limit_left_lo_x hit_limit_left_hi_x between if bally leftbaty ballsize pscale * - leftbaty batsize pscale * + between if bally leftbaty < if balldy abs negate to balldy then bally leftbaty batsize ballsize - pscale * + > if balldy abs to balldy then ballx reflect_left_x > if balldx abs random 50 / + to balldx leftbaty bally - unscale dup 0 batsize between if batsize 2 / - random * 2 / batsize / 25 / balldy + to balldy else drop then then then then then balldx 0> if ballx hit_limit_right_lo_x hit_limit_right_hi_x between if bally rightbaty ballsize pscale * - rightbaty batsize pscale * + between if bally rightbaty < if balldy abs negate to balldy then bally rightbaty batsize ballsize - pscale * + > if balldy abs to balldy then ballx reflect_right_x < if balldx abs random 50 / + negate to balldx rightbaty bally - unscale dup 0 batsize between if batsize 2 / - random * 2 / batsize / 25 / balldy + to balldy else drop then then then then then bally ball_limit_lo_y < if ball_limit_lo_y to bally then bally ball_limit_hi_y > if ball_limit_hi_y to bally then ballx bally moveball ; : updateball ( delta -- ) ballstop 0= if doupdateball else ballstop -1 = if drop else ballstop swap - to ballstop ballstop 0<= if 0 to ballstop then then then ; : movebatup ( n oldp delta -- ) { n oldp delta } erasecol n calcbatx oldp batsize + delta + ballsize delta negate paintrect drawcol n calcbatx oldp delta + ballsize delta negate paintrect ; : movebatdown ( n oldp delta -- ) { n oldp delta } erasecol n calcbatx oldp ballsize delta paintrect drawcol n calcbatx oldp batsize + ballsize delta paintrect ; : movebat ( n oldy newy -- ) { n oldy newy } newy unscale oldy unscale - dup abs batsize < if dup 0<> if dup 0< if n swap oldy unscale swap movebatup else n swap oldy unscale swap movebatdown then else drop then else drop n oldy erasebat n newy plotbat then ; : updatebats ( delta -- ) { delta } 0 leftbaty 0 over bat_limit_lo_y > if key_left_up 0<> if batdy - then then over bat_limit_hi_y < if key_left_down 0<> if batdy + then then delta * over + dup to leftbaty movebat 1 rightbaty 0 over bat_limit_lo_y > if key_right_up 0<> if batdy - then then over bat_limit_hi_y < if key_right_down 0<> if batdy + then then delta * over + dup to rightbaty movebat ; : initeverything ( -- ) cr 0 to loopcount 0 to totalupdate initvalues 10 0 do scankeys loop doreset get-msecs to glastupdate ; : doloop ( delta -- ) loopcount 1 + to loopcount dup totalupdate + to totalupdate dup updatebats dup updateball redraw glastupdate + to glastupdate ; : runpong ( -- ) initeverything begin get-msecs glastupdate - dup 0> if dup 250 > if drop get-msecs to glastupdate 250 then doloop else drop then scankeys key_esc 0<> if doreset then key_off 0<> until " Count:" type loopcount s. cr " Avg millisec:" type totalupdate loopcount / s. cr ;